Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / qbfe10.arc / EDITFLD.BAS next >

Wrap

BASIC Source File | 1987-11-27 | 19.5 KB | 389 lines

' EditField ' ' V1.0 ' ' (C) 1987 By Tony Elliott ' ' A Multi-purpose Field Editor for QuickBASIC V4.0 ' ' Please refer any comments or suggestions to the QuickBASIC ' Conference at Programmer's Information Exchange (404) 928-0033 ' ' ' 'EDITFLD.BAS Module Level Code DEFINT A-Z COMMON SHARED /editfld/ row, col, ucase, minval!, maxval!, justify, padchar, keystat, kfg, kbg, krow, kcol, sfg, sbg, dfg, dbg, insmode, nul, Alarm SUB EditField (old$, ed$, format$, retflag%) STATIC Initialize: retflag = 0 'Reset condition flag from previous calls ed$ = old$ 'Make old$ the string to edit comp$ = old$ 'Keep an original copy (before case conversions) fldlen = LEN(format$) 'Set fldlen to the length of format$. IF insmode <> 0 THEN 'If insert mode is on then insert = -1 'change value for call to setkbd. LOCATE , , , 1, 7 'Change cursor to block ELSE 'If insert is off then insert = 0 'change variable for call LOCATE , , , 6, 7 'and change cursor to flat line. END IF CALL setkbd(insert, 0, 0, 0) 'Set insert mode. 'Set Defaults IF row = 0 AND col = 0 THEN row = CSRLIN: col = POS(0) 'Use current cursor location. IF sfg = 0 AND sbg = 0 THEN sfg = 0: sbg = 7 'and background colors. IF dfg = 0 AND dbg = 0 THEN dfg = 7: dbg = 0 'when exiting the routine. IF padchar = 0 THEN padchar = 32 IF (krow = 0 AND kcol = 0) OR (kfg = 0 AND kbg = 0) THEN keystat = 0 'For keystat, turn it off. GOSUB ChangeCase 'Makes initial case conversion / UPCASE flag fieldreset = 0 'Use sfg,sbg colors IF LEFT$(format$, 1) = "\" THEN 'Checks the type of data to be ftype = 1 'input. END IF 'If ftype=1 then it is a text field IF LEFT$(format$, 1) = "#" THEN 'If ftype=2 then it is a numeric field ftype = 2 IF ucase <> 0 THEN insert = -1 IF VAL(old$) = 0 THEN 'Make sure that no string data was old$ = "" 'accidently passed in old$ comp$ = "" ELSE old$ = STR$(VAL(old$)) 'If numeric mode, make sure a numeric comp$ = old$ 'VALUE (not alphabetic characters) END IF 'was passed in old$. IF maxval! = 0 THEN 'If no value was supplied for maxval!, decloc = INSTR(format$, ".") 'find the location of the decimal. IF decloc = 0 THEN 'If no decimal, then set maxval! to maxval! = 10 ^ LEN(format$) - 1 '10 to the power of the number of digits ELSE 'in format$ minus 1, or if there is a decimal, maxval! = 10 ^ (decloc - 1) - 1 'to the power of the number of digits to the END IF 'left of the decimal minus 1. END IF END IF IF ftype = 0 THEN 'If format$ was invalid stat$ = "** Invalid FORMAT$ ! Cannot Process field! **" CALL StatLine(stat$, stat) 'Display stat$ on line 25 GOSUB Alarm 'Sound alarm retflag = 99 'Set flag to indicate error. GOSUB ResetVar 'Reset argument variables EXIT SUB 'Exit subprogram END IF GOSUB FormatField 'Display field in required format. Position: GOSUB DisplayField 'Display field contents in selected colors 'and format. Strobe: inp$ = INKEY$ 'Strobe keyboard for input GOSUB DisplayStatus 'display INS, CAPS & NUM Lock status IF inp$ = "" THEN GOTO Strobe 'Nothing here, try again. IF stat = 1 THEN 'If there is a message on the status CALL StatLine("", stat) 'line... turn it off. END IF IF LEN(inp$) = 2 THEN GOTO ExtendedKeys 'Check to see if extended key was pressed char = ASC(inp$) 'It's easier to work with numbers using CASE. SELECT CASE char 'Checks for standard characters CASE 13 'Check for return. GOTO ExitSub CASE 27 'check for ESC key. If pressed once and IF ftype = 1 THEN 'the field has been changed from its IF comp$ <> ed$ AND abort = 0 THEN 'original value, the original value will ed$ = old$ 'be restored. If pressed a second time, curpos = LEN(ed$): abort = -1 'the routine will be exited and an abort GOTO Position 'flag will be set. ELSE retflag = 1 'Set retflag to indicating an abort, GOSUB FormatField 'Reset the field display, GOSUB ResetVar 'reset argument variables and EXIT SUB 'exit the routine. END IF ELSE firstnum = 0 IF VAL(old$) <> VAL(ed$) THEN 'This handles "numeric only" data if the IF VAL(old$) > 0 THEN 'ESC was pressed ed$ = old$ 'Restore original value GOSUB FormatField 'Use special numeric formatting. GOTO Position 'Go back and display field. ELSE LOCATE row, col 'If nothing was passed in old$, PRINT SPC(fldlen); 'and no current value, erase the GOTO Position 'field. END IF ELSE retflag = 1 'ESC was pressed a second consecutive GOSUB FormatField 'time. Set retflag to indicate an "abort", GOSUB ResetVar 'reset argument variables EXIT SUB 'and exit the routine. END IF END IF CASE 8 'Check for backspace key. IF LEN(ed$) = 0 OR curpos = 0 THEN 'If on an empty field... GOSUB Alarm 'sound alarm and go back for GOTO Strobe 'more input. END IF IF LEN(ed$) > 1 THEN 'If ed$ is longer than one character then ed$ = LEFT$(ed$, curpos - 1) + RIGHT$(ed$, LEN(ed$) - (curpos)) curpos = curpos - 1 'Move cursor to left one character. ELSE ed$ = "" 'If ed$ is one character long then curpos = 0 'erase it and reset the cursor position. END IF CASE ELSE 'If any other key was pressed IF ftype = 1 THEN 'and in the text entry mode, check IF ASC(inp$) < 32 OR ASC(inp$) > 128 THEN 'if character is standard alphabetic. GOSUB Alarm 'Nope! Sound bell and display a message stat$ = "** Invalid Character! **" 'on line 25. CALL StatLine(stat$, stat) GOTO Strobe 'Go back and try again ELSE GOSUB ChangeCase 'Character passed test.. Now make the END IF 'proper case conversion. ELSE IF ASC(inp$) <> 46 AND (ASC(inp$) < 48 OR ASC(inp$) > 57) THEN '0-9 and "." (decimal). GOSUB Alarm 'Uh oh.. Gotcha stat$ = "Only Numeric Input is Allowed!" 'Sound the bell and display the CALL StatLine(stat$, stat) 'status message on line 25. GOTO Strobe 'Go back and try again. END IF IF ucase <> 0 AND firstnum = 0 THEN 'If in the numeric mode and ucase ed$ = inp$ 'is non-zero and a key has not been firstnum = 1 'pressed since the routine has been curpos = 1 'called, clear the field, set ed$ to GOSUB DisplayField 'the key pressed, set the cursor to the GOTO Strobe 'begin END IF END IF IF LEN(ed$) = fldlen AND (insert OR curpos = fldlen) THEN 'Is the field at its maximum GOSUB Alarm 'length? Yes, sound bell stat$ = "** String is at Maximum Length! **" 'display status message CALL StatLine(stat$, stat) GOTO Strobe 'Go back and try again END IF IF insert THEN 'In the insert mode, add inp$ at cursor position moving ed$ = LEFT$(ed$, curpos) + inp$ + RIGHT$(ed$, LEN(ed$) - (curpos)) 'everthing to the right of the cursor ELSE 'to the right one space. IF curpos = LEN(ed$) THEN 'If at the end of the field and in the ed$ = ed$ + inp$ 'overwrite mode, add inp$ to the end of ELSE 'ed$. MID$(ed$, curpos + 1) = inp$ 'If not at the end of the field, replace END IF 'character at the cursor's position with END IF 'inp$. curpos = curpos + 1 'Move over one space. IF curpos = fldlen THEN 'If cursor is past the end of the field curpos = fldlen - 1 'move it back. END IF END SELECT abort = 0 'Reset the ESC flag GOTO Position ExtendedKeys: 'Process the Extended Keys exkey = ASC(RIGHT$(inp$, 1)) 'Put extended key code in exkey. SELECT CASE exkey CASE 83 'Delete Key -- Deletes character at IF curpos < LEN(ed$) THEN 'cursor position. ed$ = LEFT$(ed$, curpos) + RIGHT$(ed$, LEN(ed$) - (curpos + 1)) ELSE 'If cursor is not inside the field GOSUB Alarm 'then sound bell. END IF CASE 75 'Left Arrow -- Cursor left one curpos = curpos - 1 'character. Stop at first character IF curpos < 0 THEN curpos = 0 'in field CASE 77 'Cursor-Right IF curpos < LEN(ed$) AND curpos < fldlen - 1 THEN 'Don't move past the right end of the curpos = curpos + 1 'current string or outside of the defined field END IF CASE 82 'Insert Key. Acutal changing of the IF insert THEN 'If insert is on LOCATE , , , 1, 7 'change cursor to a block. ELSE 'if not, LOCATE , , , 6, 7 'change it to a flat line END IF CASE 71 'Home Key -- Position cursor on curpos = 0 'first character in field. CASE 79 'End Key -- Cursor to last curpos = LEN(ed$) 'character in field. IF curpos = fldlen THEN 'Don't let cursor go ouside curpos = fldlen - 1 'of the field END IF CASE 119 'Ctrl-Home -- Deletes contents of ed$ = "" 'current field. curpos = 0 CASE 116 'Ctrl-Cursor Right - Move cursor to the wordloc = INSTR(curpos + 1, ed$, " ") 'right one word. IF wordloc > 0 THEN curpos = wordloc 'Space is the only valid delimeter. CASE 115 'Ctrl-Left Arrow - Word Left. FOR char = curpos TO 1 STEP -1 'Start looking for a space from the current word$ = MID$(ed$, char, 1) 'cursor position to the beginning of the field. IF word$ = " " AND char < curpos THEN 'If found, the position is flagged in the EXIT FOR '"char" variable. Exit the FOR loop. END IF 'If not found, try the next character. NEXT char 'Position cursor at flagged location. If nothing curpos = char 'was found, it will be at the beginning of the field. CASE 117 'Cntrl-End -Clear from cursor to end of field ed$ = LEFT$(ed$, curpos) 'Left trunctuate ed$ at cursor position GOSUB DisplayField 'Redisplay field CASE ELSE 'If any other extended key was pressed, retflag = exkey 'return its code in retflag. GOTO ExitSub 'This is signal to exit the routine. END SELECT GOTO Position ExitSub: IF nul <> 0 AND ((ftype = 1 AND ed$ = "") OR (ftype = 2 AND VAL(ed$) = 0)) THEN stat$ = "*** An Entry is Required. Press ESC to Abort ***" CALL StatLine(stat$, stat) 'If ed$ is nul and it is not allowed, GOSUB Alarm 'display a message, sound the bell and GOTO Position 'return for input. END IF IF ftype = 2 THEN IF (VAL(ed$) > maxval! OR VAL(ed$) < minval!) THEN stat$ = "*** Acceptable Values are" + STR$(minval!) + " -" + STR$(maxval!) + ". Please Re-enter. ***" CALL StatLine(stat$, stat) 'If value of ed$<minval! or >maxval! then GOSUB Alarm 'sound the bell.. ed$ = old$ 'restore ed$ to the original value GOSUB FormatField 'Re-display the original value in the GOTO Position 'correct format and begin again. END IF END IF fieldreset = 1 'Display field using dfg,dbg colors. GOSUB FormatField 'Retrieve the formatted output. IF ftype = 1 THEN 'If in the text entry mode, format the text SELECT CASE justify 'obeying the justify argument. CASE 1 'Left Justify ed$ = LEFT$(ed$ + STRING$(fldlen, 32), fldlen) CASE 2 'Right justify ed$ = RIGHT$(STRING$(fldlen, 32) + ed$, fldlen) CASE 3 'Center text within the width of IF LEN(ed$) < fldlen - 2 THEN 'format$. Length must be at temp$ = STRING$(fldlen, 32) 'least 2 characters less than fldpos = (fldlen - LEN(ed$)) / 2 'format$. MID$(temp$, fldpos, LEN(ed$)) = ed$ ed$ = temp$ END IF CASE ELSE 'If zero or anything else, do nothing. END SELECT GOSUB FormatField 'Re-display the formatted field ELSE IF justify <> 0 THEN 'If in the numeric mode an justify is ed$ = STR$(VAL(ed$)) 'set to a non-zero, remove the END IF 'print using format from ed$. END IF GOSUB ResetVar 'Reset argument variables EXIT SUB 'Bye-bye DisplayField: GOSUB ChangeCase 'Make case conversion. COLOR sfg, sbg 'Use "selected" colors LOCATE row, col, 0 'Position cursor IF ftype = 1 THEN 'Text print routine PRINT USING format$; ed$ + STRING$(fldlen, padchar); LOCATE row, col + LEN(ed$) ELSE PRINT LEFT$(ed$ + STRING$(fldlen, 32), fldlen)'Numeric print routine END IF LOCATE row, col + curpos, 1 RETURN FormatField: num$ = "" LOCATE row, col, 0 'Position cursor & turn off GOSUB ChangeCase 'Change to proper case IF fieldreset = 1 OR retflag = 1 THEN 'Set color based on FIELDRESET. COLOR dfg, dbg 'IF 1 then the routine is preparing ELSE 'exit, and if 0 the routine is COLOR sfg, sbg 'initializing. END IF IF ftype = 1 THEN 'Display text using format$ PRINT USING format$; ed$ ELSE IF VAL(ed$) = 0 THEN 'If ed$ has no numeric value then just PRINT SPC(fldlen); 'print spaces on the screen so entering num$ = " " 'new data is easier. ELSE PRINT USING format$; VAL(ed$) 'Print numeric data using format$. IF num$ = "" THEN FOR char = col TO col + fldlen - 1 'Read formated numeric display num$ = num$ + CHR$(SCREEN(row, char)) 'from screen into num$ for proper NEXT char 'on screen editing ed$ = num$ 'Assign ed$ with data retrieved from END IF 'display. END IF END IF IF insmode THEN 'If insert is on, position cursor at beginning curpos = 0 'of field. If off, position cursor at end ELSE 'of field (personal preference). curpos = LEN(ed$) IF curpos = fldlen THEN 'Don't let cursor wander outside curpos = fldlen - 1 'of the field END IF END IF LOCATE , , 1 'Make sure cursor is on. RETURN ChangeCase: IF ucase = 1 THEN 'Convert to upper case ed$ = UCASE$(ed$) inp$ = UCASE$(inp$) comp$ = UCASE$(comp$) ELSEIF ucase = 2 THEN 'Convert to lower case ed$ = LCASE$(ed$) inp$ = LCASE$(inp$) comp$ = LCASE$(comp$) END IF RETURN DisplayStatus: kstat$ = "" 'Nul the Keyboard status $ CALL GetKbd(insert, caps, numlk, scrl) 'Get keyboard status. IF keystat = 0 THEN RETURN 'If keystat is off, return IF insert THEN kstat$ = "INS" ELSE kstat$ = "OVW" 'Create the key status display. IF caps THEN kstat$ = kstat$ + "CAP" ELSE kstat$ = kstat$ + " " IF numlk THEN kstat$ = kstat$ + "NUM" ELSE kstat$ = kstat$ + " " CALL CalcAttr(kfg, kbg, attr) 'Calculate the color attribute. (ADVBAS or PROBAS) CALL XqPrint(kstat$, krow, kcol, attr, 0) 'Display it. (ADVBAS) 'CALL XqPrint(kstat$, krow, kcol, attr, 0, 0) 'Display it (PROBAS) RETURN ResetVar: row = 0: col = 0 'Reset variables for routine RETURN 'exit. Alarm: IF noise = 0 THEN 'Sound of error alarm .. Change to BEEP 'SOUND 1000,1:SOUND 1500,1:SOUND 1000,1 END IF 'if you don't like the regular ole "BEEP" RETURN END SUB